home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 February: Tool Chest / Dev.CD Feb 95 / Dev.CD Feb 95.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Misc.sea / Misc / no-applicable-method.lisp / no-applicable-method.lisp
Encoding:
Text File  |  1992-03-30  |  5.7 KB  |  130 lines  |  [TEXT/CCL2]
  1. ;;;-*-Mode: LISP; Package: CCL -*-
  2. ;from l1-clos.lisp
  3. ; Copyright (C) 1990 Apple Computer, Inc.  All rights reserved.
  4.  
  5. ; Gives a better error message when a generic function is called, no
  6. ; method is applicable, and an error is signalled.  The error message
  7. ; attempts to identify the problem as a specific argument being of the
  8. ; wrong type.
  9.  
  10.  
  11. (in-package :ccl)
  12.  
  13. (defmethod no-applicable-method (gf &rest args)
  14.   ;(error "No applicable method for args:~% ~s~% to ~s" args gf)
  15.   (%error (make-condition 'no-applicable-method :generic-function gf :arguments args) '()
  16.           ;; Go past the anonymous frame to the frame for the caller of the generic function
  17.           (parent-frame (%get-frame-ptr))))
  18.  
  19. (define-condition no-applicable-method (error)
  20.                   ((generic-function :initarg :generic-function)
  21.                    (arguments :initarg :arguments))
  22.  (:report (lambda (condition stream)
  23.            (labels ((satisfies (argument specializer)
  24.                       (if (consp specializer)
  25.                           (eql argument (second specializer))
  26.                           (typep argument specializer)))
  27.                     (comma (conjunction more all)
  28.                       (when more
  29.                         (when (cddr all) (write-string "," stream))
  30.                         (unless (cdr more)
  31.                           (write-string " " stream)
  32.                           (write-string conjunction stream))
  33.                         (write-string " " stream)))
  34.                     (print-type (type)
  35.                       (prin1 (or (and (classp type) (class-name type)) type) stream)))
  36.              (with-slots (generic-function arguments) condition
  37.                (format stream "No applicable method for ~S." 
  38.                        (or (function-name generic-function) generic-function))
  39.                (let* ((methods (generic-function-methods generic-function))
  40.                       (n-required (function-args generic-function))
  41.                       (matches (make-list n-required :initial-element nil))
  42.                       (t-class (find-class t)))
  43.                  ;; Find argument positions with no matching methods
  44.                  (dolist (method methods)
  45.                    (loop for specializer in (method-specializers method)
  46.                          and argno from 0
  47.                          and arg in arguments do
  48.                      (when (satisfies arg specializer)
  49.                        (setf (elt matches argno) t))))
  50.                  (if (some #'null matches)
  51.                    ;; Report the specializers of methods for argument positions that did not match
  52.                    (loop for argno from 0
  53.                          and arg in arguments
  54.                          and match in matches do
  55.                      (unless match
  56.                        (format stream "~%The ~:R argument, ~S, was of the wrong type." (1+ argno) arg)
  57.                        (let ((types (loop for method in methods
  58.                                           as specializers = (method-specializers method)
  59.                                       when (loop for specializer in specializers
  60.                                                  and method-argno from 0
  61.                                                  and arg in arguments
  62.                                              always (or (not (elt matches method-argno))
  63.                                                         (satisfies arg specializer)))
  64.                                         collect (elt specializers argno))))
  65.                          (when types
  66.                            (format stream "~%An argument of type ")
  67.                            (loop for (type . more) on types do
  68.                              (print-type type)
  69.                              (comma "or" more types))
  70.                            (write-string " was expected." stream)))))
  71.                    ;; No single argument position is at fault
  72.                    ;; Report the available argument type combinations
  73.                    (let ((specialized nil))
  74.                      (dolist (method methods)
  75.                        (loop for specializer in (method-specializers method)
  76.                              and argno from 0 do
  77.                          (unless (eq specializer t-class)
  78.                            (pushnew argno specialized))))
  79.                      (setq specialized (nreverse specialized))
  80.                      (format stream "~%The ")
  81.                      (loop for (argno . more) on specialized do
  82.                        (format stream "~:R" (1+ argno))
  83.                        (comma "and" more specialized))
  84.                      (format stream " arguments, ")
  85.                      (loop for (argno . more) on specialized do
  86.                        (format stream "~S" (elt arguments argno))
  87.                        (comma "and" more specialized))
  88.                      (format stream ", were of the wrong type.~%Acceptable combinations of types are:")
  89.                      (dolist (method methods)
  90.                        (format stream "~%  ")
  91.                        (loop for (argno . more) on specialized
  92.                              as type = (elt (method-specializers method) argno) do
  93.                          (print-type type)
  94.                          (comma "and" more specialized)))))))))))
  95.  
  96. #||
  97.  
  98. ;;; Test cases
  99.  
  100. (defun tst (x y) (print (f1 x y)))
  101.  
  102. (defclass c1 () ())
  103. (defclass c2 () ())
  104. (defclass c3 () ())
  105. (defclass c4 (c1) ())
  106. (defvar c1 (make-instance 'c1))
  107. (defvar c2 (make-instance 'c2))
  108. (defvar c3 (make-instance 'c3))
  109. (defvar c4 (make-instance 'c4))
  110.  
  111. (defmethod f1 ((self c1) (x integer)) 1)
  112.  
  113. (tst c1 t)
  114. (tst c2 t)
  115. (tst c2 0)
  116.  
  117. (defmethod f1 ((self c1) (x float)) 2)
  118.  
  119. (tst c1 t)
  120.  
  121. (defmethod f1 ((self c1) (x c2)) 2)
  122.  
  123. (tst c1 t)
  124.  
  125. (defmethod f1 ((self c2) (x symbol)) 2)
  126.  
  127. (tst c1 t)
  128.  
  129. ||#
  130.